home *** CD-ROM | disk | FTP | other *** search
/ CD ROM Paradise Collection 4 / CD ROM Paradise Collection 4 1995 Nov.iso / program / swagg_m.zip / GRAPHICS.SWG / 0066_PCX Writing.pas < prev    next >
Pascal/Delphi Source File  |  1994-01-27  |  13KB  |  417 lines
  1. {
  2. As I follow this forum, many requests are made for PCX graphics
  3. file routines. Those that are looking for Read_PCX info can
  4. find it on the ZSoft BBS in a wonderful Pascal example: ShowPCX.
  5.  
  6. On the other hand, there is next to zilch out there on how to
  7. Write_PCX files. I know.... I searched and searched and couldn't
  8. find a thing! So with a little brute force  and a few ZSoft
  9. C language snippets <groan>, I got this together:
  10.  
  11. PCX_W.Write_PCX (Name:Str80);
  12. given to the public domain and commonweal.
  13. pseudocode:
  14.            set 640x480x16 VGAhi graphics mode only for now
  15.            getimage 1 row at a time
  16.            reorganize the BGI color planes into PCX format order
  17.            encode the raw PCX line into a run length limited
  18.              compressed PCX line
  19.            blockwrite the compressed PCX line to your.PCX file
  20. }
  21.  
  22. {$R-}    {Range checking, turn off when debugged}
  23.  
  24. unit PCX_W;
  25.  
  26. { --------------------- Interface ----------------- }
  27.  
  28. interface
  29.  
  30. type
  31.     Str80 = string [80];
  32.  
  33. procedure Write_PCX  (Name:Str80);
  34.  
  35.  
  36. { ===================== Implementation ============ }
  37.  
  38. implementation
  39.  
  40. uses
  41.     Graph;
  42.  
  43.  
  44. {-------------- Write_PCX --------------}
  45.  
  46. procedure Write_PCX (Name:Str80);
  47.  
  48. const
  49.      RED1   = 0;
  50.      GREEN1 = 1;
  51.      BLUE1  = 2;
  52.  
  53. type
  54.     ArrayPal   = array [0..15, RED1..BLUE1] of byte;
  55.  
  56. const
  57.      MAX_WIDTH  = 4000;    { arbitrary - maximum width (in bytes) of
  58.                              a PCX image }
  59.      INTENSTART =   $5;
  60.      BLUESTART  =  $55;
  61.      GREENSTART =  $A5;
  62.      REDSTART   =  $F5;
  63.  
  64. type
  65.     Pcx_Header = record
  66.     {comments from ZSoft ShowPCX pascal example}
  67.  
  68.         Manufacturer: byte;     { Always 10 for PCX file }
  69.  
  70.         Version: byte;          { 2 - old PCX - no palette (not used
  71.                                       anymore),
  72.                                   3 - no palette,
  73.                                   4 - Microsoft Windows - no palette
  74.                                       (only in old files, new Windows
  75.                                       version uses 3),
  76.                                   5 - with palette }
  77.  
  78.         Encoding: byte;         { 1 is PCX, it is possible that we may
  79.                                   add additional encoding methods in the
  80.                                   future }
  81.  
  82.         Bits_per_pixel: byte;   { Number of bits to represent a pixel
  83.                                   (per plane) - 1, 2, 4, or 8 }
  84.  
  85.         Xmin: integer;          { Image window dimensions (inclusive) }
  86.         Ymin: integer;          { Xmin, Ymin are usually zero (not always)}
  87.         Xmax: integer;
  88.         Ymax: integer;
  89.  
  90.         Hdpi: integer;          { Resolution of image (dots per inch) }
  91.         Vdpi: integer;          { Set to scanner resolution - 300 is
  92.                                   default }
  93.  
  94.         ColorMap: ArrayPal;
  95.                                 { RGB palette data (16 colors or less)
  96.                                   256 color palette is appended to end
  97.                                   of file }
  98.  
  99.         Reserved: byte;         { (used to contain video mode)
  100.                                   now it is ignored - just set to zero }
  101.  
  102.         Nplanes: byte;          { Number of planes }
  103.  
  104.         Bytes_per_line_per_plane: integer;   { Number of bytes to
  105.                                                allocate for a scanline
  106.                                                plane. MUST be an an EVEN
  107.                                                number! Do NOT calculate
  108.                                                from Xmax-Xmin! }
  109.  
  110.         PaletteInfo: integer;   { 1 = black & white or color image,
  111.                                   2 = grayscale image - ignored in PB4,
  112.                                       PB4+ palette must also be set to
  113.                                       shades of gray! }
  114.  
  115.         HscreenSize: integer;   { added for PC Paintbrush IV Plus
  116.                                   ver 1.0,  }
  117.         VscreenSize: integer;   { PC Paintbrush IV ver 1.02 (and later)}
  118.                                 { I know it is tempting to use these
  119.                                   fields to determine what video mode
  120.                                   should be used to display the image
  121.                                   - but it is NOT recommended since the
  122.                                   fields will probably just contain
  123.                                   garbage. It is better to have the
  124.                                   user install for the graphics mode he
  125.                                   wants to use... }
  126.  
  127.         Filler: array [74..127] of byte;     { Just set to zeros }
  128.     end;
  129.  
  130.     Array80    = array [1..80]        of byte;
  131.     ArrayLnImg = array [1..326]       of byte; { 6 extra bytes at
  132.      beginng of line that BGI uses for size info}
  133.     Line_Array = array [0..MAX_WIDTH] of byte;
  134.     ArrayLnPCX = array [1..4]         of Array80;
  135.  
  136. var
  137.    PCXName   : File;
  138.    Header    : Pcx_Header;                 { PCX file header }
  139.    ImgLn     : ArrayLnImg;
  140.    PCXLn     : ArrayLnPCX;
  141.    RedLn,
  142.    BlueLn,
  143.    GreenLn,
  144.    IntenLn   : Array80;
  145.    Img       : pointer;
  146.  
  147.  
  148. {-------------- BuildHeader- -----------}
  149.  
  150. procedure BuildHeader;
  151.  
  152. const
  153.      PALETTEMAP: ArrayPal=
  154.                  {  R    G    B                    }
  155.                 (($00, $00, $00),  {  black        }
  156.                  ($00, $00, $AA),  {  blue         }
  157.                  ($00, $AA, $00),  {  green        }
  158.                  ($00, $AA, $AA),  {  cyan         }
  159.                  ($AA, $00, $00),  {  red          }
  160.                  ($AA, $00, $AA),  {  magenta      }
  161.                  ($AA, $55, $00),  {  brown        }
  162.                  ($AA, $AA, $AA),  {  lightgray    }
  163.                  ($55, $55, $55),  {  darkgray     }
  164.                  ($55, $55, $FF),  {  lightblue    }
  165.                  ($55, $FF, $55),  {  lightgreen   }
  166.                  ($55, $FF, $FF),  {  lightcyan    }
  167.                  ($FF, $55, $55),  {  lightred     }
  168.                  ($FF, $55, $FF),  {  lightmagenta }
  169.                  ($FF, $FF, $55),  {  yellow       }
  170.                  ($FF, $FF, $FF) );{  white        }
  171.  
  172. var
  173.    i : word;
  174.  
  175. begin
  176.      with Header do
  177.           begin
  178.                Manufacturer  := 10;
  179.                Version  := 5;
  180.                Encoding := 1;
  181.                Bits_per_pixel := 1;
  182.                Xmin := 0;
  183.                Ymin := 0;
  184.                Xmax := 639;
  185.                Ymax := 479;
  186.                Hdpi := 640;
  187.                Vdpi := 480;
  188.                ColorMap := PALETTEMAP;
  189.                Reserved := 0;
  190.                Nplanes  := 4; { Red, Green, Blue, Intensity }
  191.                Bytes_per_line_per_plane := 80;
  192.                PaletteInfo := 1;
  193.                HscreenSize := 0;
  194.                VscreenSize := 0;
  195.                for i := 74 to 127 do
  196.                    Filler [i] := 0;
  197.           end;
  198. end;
  199.  
  200.  
  201. {-------------- GetBGIPlane ------------}
  202.  
  203. procedure GetBGIPlane (Start:word; var Plane:Array80);
  204.  
  205. var
  206.    i : word;
  207.  
  208. begin
  209.      for i:= 1 to Header.Bytes_per_line_per_plane do
  210.          Plane [i] := ImgLn [Start +i -1]
  211. end;
  212.  
  213. {-------------- BuildPCXPlane ----------}
  214.  
  215. procedure BuildPCXPlane (Start:word; Plane:Array80);
  216.  
  217. var
  218.    i : word;
  219.  
  220. begin
  221.      for i := 1 to Header.Bytes_per_line_per_plane do
  222.          PCXLn [Start] [i] := Plane [i];
  223. end;
  224.  
  225.  
  226. {-------------- EncPCXLine -------------}
  227.  
  228. procedure EncPCXLine (PlaneLine : word); { Encode a PCX line }
  229.  
  230. var
  231.    This,
  232.    Last,
  233.    RunCount : byte;
  234.    i,
  235.    j        : word;
  236.  
  237.  
  238.   {-------------- EncPut -----------------}
  239.  
  240.   procedure EncPut (Byt, Cnt :byte);
  241.  
  242.   const
  243.        COMPRESS_NUM = $C0;  { this is the upper two bits that
  244.                               indicate a count }
  245.  
  246.   var
  247.      Holder : byte;
  248.  
  249.   begin
  250.   {$I-}
  251.        if (Cnt = 1) and (COMPRESS_NUM <> (COMPRESS_NUM and Byt)) then
  252.           blockwrite (PCXName, Byt,1)          { single occurance }
  253.           {good place for file error handler!}
  254.        else
  255.            begin
  256.                 Holder := (COMPRESS_NUM or Cnt);
  257.                 blockwrite (PCXName, Holder, 1); { number of times the
  258.                                                    following color
  259.                                                    occurs }
  260.                 blockwrite (PCXName, Byt, 1);
  261.            end;
  262.   {$I+}
  263.   end;
  264.  
  265.  
  266. begin
  267.      i := 1;         { used in PCXLn }
  268.      RunCount := 1;
  269.      Last := PCXLn [PlaneLine][i];
  270.      for j := 1 to Header.Bytes_per_line_per_plane -1 do
  271.          begin
  272.               inc (i);
  273.               This := PCXLn [PlaneLine][i];
  274.               if This = Last then
  275.                  begin
  276.                       inc (RunCount);
  277.                       if RunCount = 63 then   { reached PCX run length
  278.                                                 limited max yet? }
  279.                          begin
  280.                               EncPut (Last, RunCount);
  281.                               RunCount := 0;
  282.                          end;
  283.                  end
  284.               else
  285.                   begin
  286.                        if RunCount >= 1 then
  287.                           Encput (Last, RunCount);
  288.                        Last := This;
  289.                        RunCount := 1;
  290.                   end;
  291.          end;
  292.      if RunCount >= 1 then  { any left over ? }
  293.         Encput (Last, RunCount);
  294. end;
  295.  
  296.             { - - -W-R-I-T-E-_-P-C-X- - - - - - - - }
  297.  
  298. const
  299.      XMAX = 639;
  300.      YMAX = 479;
  301.  
  302. var
  303.    i, j, Size : word;
  304.  
  305. begin
  306.      BuildHeader;
  307.      assign     (PCXName,Name);
  308. {$I-}
  309.      rewrite    (PCXName,1);
  310.      blockwrite (PCXName,Header,sizeof (Header));
  311.      {good place for file error handler!}
  312. {$I+}
  313.      setviewport (0,0,XMAX,YMAX, ClipOn);
  314.      Size := imagesize (0,0,XMAX,0); { size of a single row }
  315.      getmem (Img,Size);
  316.  
  317.      for i := 0 to YMAX do
  318.          begin
  319.               getimage (0,i,XMAX,i,Img^);  { Grab 1 line from the
  320.                                              screen store in Img
  321.                                              buffer  }
  322.               move (Img^,ImgLn,Size {326});
  323.  
  324.               GetBGIPlane (INTENSTART, IntenLn);
  325.               GetBGIPlane (BLUESTART,  BlueLn );
  326.               GetBGIPlane (GREENSTART, GreenLn);
  327.               GetBGIPlane (REDSTART,   RedLn  );
  328.               BuildPCXPlane (1, RedLn  );
  329.               BuildPCXPlane (2, GreenLn);
  330.               BuildPCXPlane (3, BlueLn );
  331.               BuildPCXPlane (4, IntenLn); { 320 bytes/line
  332.                                             uncompressed }
  333.               for j := 1 to Header.NPlanes do
  334.  
  335.                   EncPCXLine (j);
  336.          end;
  337.      freemem (Img,Size);           (* Release the memory        *)
  338. {$I-}
  339.      close (PCXName);              (* Save the Image            *)
  340. {$I+}
  341. end;
  342.  
  343. end {PCX.TPU} .
  344.  
  345.  
  346. { -----------------------Test Program -------------------------- }
  347.  
  348. program WritePCX;
  349.  
  350. uses
  351.     Graph, PCX_W;
  352.  
  353. {-------------- DrawHorizBars ----------}
  354.  
  355. procedure DrawHorizBars;
  356.  
  357. var
  358.    i, Color : word;
  359.  
  360. begin
  361.      cleardevice;
  362.      Color := 15;
  363.      for i := 0 to 15 do
  364.          begin
  365.               setfillstyle (solidfill,Color);
  366.               bar (0,i*30,639,i*30+30);       { 16*30 = 480 }
  367.               dec (Color);
  368.          end;
  369. end;
  370.  
  371. {-------------- Main -------------------}
  372.  
  373. var
  374.    NameW : Str80;
  375.    Gd,
  376.    Gm    : integer;
  377.  
  378. begin
  379.      writeln;
  380.      if (ParamCount = 0) then           { no DOS command line
  381.                                           parameters }
  382.         begin
  383.              write ('Enter name of PCX picture file to write: ');
  384.              readln (NameW);
  385.              writeln;
  386.         end
  387.      else
  388.          begin
  389.               NameW := paramstr (1);  { get filename from DOS
  390.                                         command line }
  391.          end;
  392.  
  393.      if (Pos ('.', NameW) = 0) then   { make sure the filename
  394.                                         has PCX extension }
  395.         NameW := Concat (NameW, '.pcx');
  396.  
  397.      Gd:=VGA;
  398.      Gm:=VGAhi; {640x480, 16 colors}
  399.      initgraph (Gd,Gm,'..\bgi');  { path to your EGAVGA.BGI }
  400.  
  401.      DrawHorizBars;
  402.  
  403.      readln;
  404.      Write_PCX (NameW); { PCX_W.TPU }
  405.      closegraph;                    { Close graphics    }
  406.      textmode (co80);               { back to text mode }
  407. end.  { Write_PCX }
  408.  
  409. {
  410. OK, everybody, I hope this gets you started. I had a lot of
  411. fun setting it up. There are some obvious places that need
  412. optimization... especially the disk intensive blockwrites. If
  413. someone could please figure out holding about 4k or so in pointers
  414. of the encoded PCX file before writing, I'd sure appreciate it!.
  415. (please post for everyone, if you do.)
  416.  
  417. }